home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / edit-faces.el.z / edit-faces.el
Encoding:
Text File  |  1998-05-21  |  11.2 KB  |  356 lines
  1. ;;; edit-faces.el -- interactive face editing mode
  2.  
  3. ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
  4. ;; Copyright (C) 1996 Ben Wing.
  5. ;; 
  6. ;; This file is part of XEmacs.
  7. ;; 
  8. ;; XEmacs is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2 of the License, or
  11. ;; (at your option) any later version.
  12. ;; 
  13. ;; XEmacs is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17. ;; 
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with XEmacs; if not, write to the Free Software
  20. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ;;; Synched up with: Not in FSF.
  23. ;;; #### FSF has facemenu.el.  Should merge with.
  24.  
  25. ;;; Original author: Stig <stig@hackvan.com>.
  26. ;;; Significantly fixed up: Ben Wing <wing@666.com>.
  27.  
  28. (defvar edit-faces-menu
  29.   '("Edit-Faces"
  30.     ["Copy other face..." ef-copy-other-face t]
  31.     ["Copy this face..." ef-copy-this-face t]
  32.     ["Make smaller"    ef-smaller    t]
  33.     ["Make larger"    ef-larger    t]
  34.     ["Toggle bold"    ef-bold        t]
  35.     ["Toggle italic"    ef-italic    t]
  36.     ["Toggle underline"    ef-underline    t]
  37.     ["Query true font"    ef-truefont    t]
  38.     ["Set font"        ef-font        t]
  39.     ["Set foreground"    ef-foreground    t]
  40.     ["Set background"    ef-background    t]
  41.     ["Set doc string"    ef-doc-string    t]
  42.     ["Quit"        ef-quit        t]
  43.     ))
  44.  
  45. (or (find-face 'underline)
  46.     (progn (make-face 'underline)
  47.        (set-face-underline-p 'underline t)))
  48.  
  49. (define-derived-mode edit-faces-mode list-mode
  50.   "Edit-Faces"
  51.   "Major mode for `edit-faces' buffers.
  52.  
  53. Editing commands:
  54.  
  55. \\{edit-faces-mode-map}"
  56.   (setq truncate-lines t)
  57.   ;; auto-show-mode is too confusing in this mode
  58.   (setq auto-show-mode nil)
  59.   (setq    mode-popup-menu edit-faces-menu)
  60.   (if (featurep 'menubar)
  61.       (if current-menubar
  62.       (progn
  63.         (set (make-local-variable 'current-menubar)
  64.          (copy-sequence current-menubar))
  65.         (add-submenu nil edit-faces-menu)))))
  66.  
  67. (let ((map edit-faces-mode-map))
  68.   (define-key map "<" 'ef-smaller)
  69.   (define-key map ">" 'ef-larger)
  70.   (define-key map "c" 'ef-copy-other-face)
  71.   (define-key map "C" 'ef-copy-this-face)
  72.   (define-key map "s" 'ef-smaller)
  73.   (define-key map "l" 'ef-larger)
  74.   (define-key map "b" 'ef-bold)
  75.   (define-key map "i" 'ef-italic)
  76.   (define-key map "e" 'ef-font)
  77.   (define-key map "f" 'ef-font)
  78.   (define-key map "u" 'ef-underline)
  79.   (define-key map "t" 'ef-truefont)
  80.   (define-key map "F" 'ef-foreground)
  81.   (define-key map "B" 'ef-background)
  82.   (define-key map "D" 'ef-doc-string)
  83.   (define-key map "d" 'ef-delete)
  84.   (define-key map "n" 'ef-next)
  85.   (define-key map "p" 'ef-prev)
  86.   (define-key map " " 'ef-next)
  87.   (define-key map "\C-?" 'ef-prev)
  88.   (define-key map "g" 'edit-faces)    ; refresh display
  89.   (define-key map "q" 'ef-quit)
  90.   (define-key map "\C-c\C-c" 'bury-buffer))
  91.  
  92. ;;;###autoload
  93. (defun edit-faces ()
  94.   "Alter face characteristics by editing a list of defined faces.
  95. Pops up a buffer containing a list of defined faces.
  96.  
  97. Editing commands:
  98.  
  99. \\{edit-faces-mode-map}"
  100.   (interactive)
  101.   (pop-to-buffer (get-buffer-create "*Edit Faces*"))
  102.   (reset-buffer (current-buffer))
  103.  
  104.   ;; face-list returns faces in a random order so we sort
  105.   ;; alphabetically by the name in order to insert some logic into
  106.   ;; the ordering.
  107.   (let ((flist (sort (face-list)
  108.              (function
  109.               (lambda (x y)
  110.             (string-lessp (symbol-name x) (symbol-name y))))))
  111.     face)
  112.     (ef-update-face-description t)    ; insert header line
  113.     (while (setq face (car flist))
  114.       (ef-update-face-description face)
  115.       (setq flist (cdr flist))
  116.       ))
  117.   (edit-faces-mode)
  118. )
  119.  
  120. (defun ef-foreground-callback (event extent user-data)
  121.   (ef-foreground (ef-face-arg (extent-start-position extent)
  122.                   (extent-object extent))))
  123.   
  124. (defun ef-background-callback (event extent user-data)
  125.   (ef-background (ef-face-arg (extent-start-position extent)
  126.                   (extent-object extent))))
  127.  
  128. (defun ef-font-callback (event extent user-data)
  129.   (ef-font (ef-face-arg (extent-start-position extent)
  130.             (extent-object extent))))
  131.  
  132. (defun ef-doc-string-callback (event extent user-data)
  133.   (ef-doc-string (ef-face-arg (extent-start-position extent)
  134.                   (extent-object extent))))
  135.  
  136. (defun ef-update-face-description (face &optional replace)
  137.   "Given a face, inserts a description of that face into the current buffer.
  138. Inserts a descriptive header if passed `t'."
  139.   (let ((face-name-fmt "%-25s")
  140.     (foreground-fmt "%-15s")
  141.     (background-fmt "%-15s")
  142.     (font-fmt "%s")
  143.     (buffer-read-only nil)
  144.     fg bg font)
  145.     (if (eq face t)
  146.     (insert-face (format (concat face-name-fmt " " foreground-fmt " "
  147.                      background-fmt " " font-fmt "\n")
  148.                  "Face" "Foreground" "Background" "Font Spec")
  149.              'underline)
  150.       (or replace (setq replace face))
  151.       (goto-char (point-min)) 
  152.       (if (re-search-forward (concat "^" (symbol-name replace) " ") nil 0)
  153.       (progn
  154.         (beginning-of-line)
  155.         (delete-region (point) (progn (forward-line 2) (point)))
  156.         ))
  157.       (setq fg (face-foreground-instance face)
  158.         bg (face-background-instance face)
  159.         font (face-font-instance face))
  160.       (let ((st (point))
  161.         (fn #'(lambda (str callback)
  162.             (let ((st1 (point)))
  163.               (insert str)
  164.               (add-list-mode-item st1 (point) nil callback)))))
  165.     (funcall fn (format face-name-fmt (symbol-name face)) nil)
  166.     (insert " ")
  167.     (funcall fn (format foreground-fmt (color-instance-name fg))
  168.          'ef-foreground-callback)
  169.     (insert " ")
  170.     (funcall fn (format background-fmt (color-instance-name bg))
  171.          'ef-background-callback)
  172.     (insert " ")
  173.     (funcall fn (format font-fmt (font-instance-name font))
  174.          'ef-font-callback)
  175.     (insert "\n  (")
  176.     (funcall fn (or (face-doc-string face) "")
  177.          'ef-doc-string-callback)
  178.     (insert ")")
  179.     (add-nonduplicable-text-properties st (point)
  180.                        `(face ,face eface ,face
  181.                           start-open t))
  182.     (insert "\n")
  183.     )
  184.       (and replace (forward-line -1))
  185.       ))
  186.   )
  187.  
  188. (defun ef-face-arg (&optional pos buffer)
  189.   (if (and (not pos) (not buffer))
  190.       (and current-mouse-event
  191.        (mouse-event-p current-mouse-event)
  192.        (mouse-set-point current-mouse-event)))
  193.   (or buffer (setq buffer (current-buffer)))
  194.   (or pos (setq pos (point buffer)))
  195.   (let ((face (or (get-char-property pos 'eface buffer)
  196.           (and (> pos (point-min buffer))
  197.                (get-char-property (1- pos) 'eface buffer)))))
  198.     (or face (error "There is no face to edit on this line."))
  199.     face))
  200.  
  201. (defun ef-delete (arg)
  202.   "Delete the face on the current line from the *Edit Faces* buffer.
  203. The face is not altered.  The buffer can be regenerated again with
  204. M-x edit-faces."
  205.   (interactive "p") 
  206.   (and current-mouse-event (mouse-event-p current-mouse-event)
  207.        (mouse-set-point current-mouse-event))
  208.   (let ( ;; is this worth the bother? (fwd (> arg 0))
  209.     (count (abs arg))
  210.     (buffer-read-only nil)
  211.     ex)
  212.     (while (not (zerop (prog1 count (setq count (1- count)))))
  213.       (setq ex (text-property-bounds (point) 'eface nil 'at))
  214.       (or ex (error "There is no face to delete on this line."))
  215.       (delete-region (car ex) (cdr ex))
  216.       (delete-blank-lines))))
  217.   
  218. (defun ef-next (arg)
  219.   "Move forward ARG entries in the face table."
  220.   (interactive "p") 
  221.   (let ((bounds (next-text-property-bounds arg (point) 'eface)))
  222.     (if bounds (goto-char (car bounds))
  223.       (goto-char (if (> arg 0) (point-max) (point-min))))))
  224.  
  225. (defun ef-prev (arg)
  226.   "Move forward ARG entries in the face table."
  227.   (interactive "p") 
  228.   (ef-next (- arg)))
  229.  
  230. (defun ef-smaller (face)
  231.   (interactive (list (ef-face-arg)))
  232.   (make-face-smaller face)
  233.   (ef-update-face-description face))
  234.  
  235. (defun ef-larger (face)
  236.   (interactive (list (ef-face-arg)))
  237.   (make-face-larger face)
  238.   (ef-update-face-description face))
  239.  
  240. (defun ef-face-font-indirect (face)
  241.   (let ((font (face-font-instance face)))
  242.     (or font (face-font-instance 'default))))
  243.  
  244. (defun ef-face-bold-p (face)
  245.   (let ((font (ef-face-font-indirect face)))
  246.     (not (not (string-match "-bold-" (font-instance-name font))))))
  247.  
  248. (defun ef-face-italic-p (face)
  249.   (let ((font (ef-face-font-indirect face)))
  250.     (not (not (string-match "-[io]-" (font-instance-name font))))))
  251.  
  252. (defun ef-bold (face)
  253.   (interactive (list (ef-face-arg)))
  254.   (if (ef-face-bold-p face)
  255.       (make-face-unbold face)
  256.     (make-face-bold face))
  257.   (ef-update-face-description face))
  258.  
  259. (defun ef-italic (face)
  260.   (interactive (list (ef-face-arg)))
  261.   (if (ef-face-italic-p face)
  262.       (make-face-unitalic face)
  263.     (make-face-italic face))
  264.   (ef-update-face-description face))
  265.  
  266. (defun ef-underline (face)
  267.   (interactive (list (ef-face-arg)))
  268.   (set-face-underline-p face (not (face-underline-p face)))
  269.   (ef-update-face-description face))
  270.  
  271. (defun ef-truefont (face)
  272.   (interactive (list (ef-face-arg)))
  273.   (let ((font (face-font-instance face))
  274.     (name (symbol-name face)))
  275.     (if font
  276.     (message "True font for `%s': %s" name (font-instance-truename font))
  277.       (message "The face `%s' does not have its own font." name))))
  278.  
  279. (defun ef-foreground (face)
  280.   (interactive
  281.    (list (ef-face-arg)))
  282.   (set-face-foreground
  283.    face
  284.    (read-color (format "Foreground color for `%s': " (symbol-name face))
  285.            nil
  286.            (color-instance-name (face-foreground-instance face))))
  287.   (ef-update-face-description face))
  288.  
  289. (defun ef-background (face)
  290.   (interactive
  291.    (list (ef-face-arg)))
  292.   (set-face-background
  293.    face
  294.    (read-color (format "Background color for `%s': " (symbol-name face))
  295.            nil
  296.            (color-instance-name (face-background-instance face))))
  297.   (ef-update-face-description face))
  298.  
  299. (defun ef-doc-string (face)
  300.   (interactive
  301.    (list (ef-face-arg)))
  302.   (set-face-doc-string
  303.    face
  304.    (read-string (format "Doc string for `%s': " (symbol-name face))
  305.         (face-doc-string face)))
  306.   (ef-update-face-description face))
  307.  
  308. (defun ef-copy-other-face (src dst)
  309.   (interactive
  310.    (let* ((f (ef-face-arg))
  311.       (name (symbol-name f)))
  312.      (list (read-face (format "Make `%s' a copy of what face?: " name) t) f)))
  313.   (copy-face src dst)
  314.   (ef-update-face-description dst dst))
  315.  
  316. (defun ef-copy-this-face (src dst)
  317.   (interactive
  318.    (let* ((f (ef-face-arg))
  319.       (name (symbol-name f)))
  320.        (list f (read-face (format "Copy `%s' onto what face?: " name)))))
  321.   (copy-face src dst)
  322.   (ef-update-face-description dst dst))
  323.  
  324. (defun ef-font (face)
  325.   (interactive
  326.    (list (ef-face-arg)))
  327.   (let* ((ofont (face-font-instance face))
  328.      (font (read-string (format "Font for `%s': " (symbol-name face))
  329.                 (font-instance-name (face-font-instance face))))
  330.      others)
  331.     ;; you might think that this could be moved into the loop below, but I
  332.     ;; think that it's important to see the new font before asking if the
  333.     ;; change should be global. 
  334.     (set-face-font face (if (and (string= font "")
  335.                  (not (eq face 'default)))
  336.                 nil font))
  337.     (ef-update-face-description face)
  338.     (setq others (delq nil (mapcar (lambda (f)
  339.                      (and (equal (face-font-instance f) ofont)
  340.                       f))
  341.                    (face-list))))
  342.     (if (and others
  343.          (y-or-n-p "Make the same font change for other faces? "))
  344.     (while others
  345.       (setq face (car others)
  346.         others (cdr others))
  347.       (set-face-font face font)
  348.       (ef-update-face-description face)))
  349.     ))
  350.  
  351. (defun ef-quit ()
  352.   (interactive)
  353.   (or (one-window-p t 0)
  354.       (delete-window))
  355.   (kill-buffer "*Edit Faces*"))
  356.